home *** CD-ROM | disk | FTP | other *** search
/ The Programmer Disk / The Programmer Disk (Microforum).iso / xpro / qb2 / pro24 / qbfuncs.bas < prev    next >
Encoding:
BASIC Source File  |  1992-05-05  |  15.5 KB  |  424 lines
  1. 'These Functions need to be loaded with the BFUNCS libary
  2. 'BFUNCS.LIB for compile time.  BFUNCS.QLB for QBX time.
  3. '$INCLUDE: 'nicehdr'
  4.  
  5. DEFINT A-Z
  6. DEFINT A-Z
  7. FUNCTION Blanks% (Strig$)
  8.  
  9. '----------------------------------------------------------
  10. 'Function that returns a boolean value of true if the string consists
  11. 'entirely of spaces and null characters; otherwise false.
  12. '----------------------------------------------------------
  13.  
  14.   LENGTH = LEN(Strig$)
  15.   FOR X = 1 TO LENGTH
  16.     CH$ = MID$(Strig$, X, 1)
  17.     IF ASC(CH$) <> 0 AND ASC(CH$) <> 32 THEN Blanks = 0: EXIT FUNCTION
  18.   NEXT X
  19.   Blanks = -1
  20.  
  21. END FUNCTION
  22.  
  23. DEFSNG A-Z
  24. DEFINT A-Z
  25. DEFINT A-Z
  26. FUNCTION CheckSum (NUM$)
  27.  
  28. 'checks NUM$ with a funky mathematical algorithm that all valid invitation,
  29. 'account, and reference numbers fit into.  Returns true for valid false if not.
  30.  
  31.             RETCODE = -1
  32.             RESULT = 0
  33.             FOR l = 1 TO (LEN(NUM$) - 1)
  34.               IF LEN(NUM$) MOD 2 = 1 THEN
  35.                 MULT = 2 - (l MOD 2)
  36.               ELSE
  37.                 MULT = 1 + (l MOD 2)
  38.               END IF
  39.  
  40.               DIG = VAL(MID$(NUM$, l, 1))
  41.  
  42.               DIG = DIG * MULT
  43.               IF DIG > 9 THEN
  44.                 DIG = 1 + (DIG MOD 10)
  45.               END IF
  46.  
  47.               RESULT = RESULT + DIG
  48.             NEXT l
  49.             RESULT = (10 - (RESULT MOD 10)) MOD 10
  50.  
  51.             DIG = VAL(RIGHT$(NUM$, 1))
  52.  
  53.             IF (DIG <> RESULT) THEN
  54.                RETCODE = 0
  55.             END IF
  56.  
  57.             CheckSum = RETCODE
  58. END FUNCTION
  59.  
  60. DEFSNG A-Z
  61. DEFINT A-Z
  62. DEFINT A-Z
  63. SUB Enterinfo (ROW, COL, LENGTH, COLR1, COLR2, Data$, MODE, SHOW, VKEY$, RET)
  64.  
  65. 'This subroutine is for entering a designated length of data from
  66. 'the keyboard.
  67.  
  68. '----VARIABLE-----------------------DESCRIPTION------------------------
  69. '    ROW%               ;ROW TO START ENTERING INFORMATION
  70. '    COL%               ;COLUMN TO START ENTERING INFORMATION
  71. '    LENGTH%            ;MAX LENGTH OF DATA TO BE ENTERED
  72. '    COLR1%             ;FOREGROUND COLOR
  73. '    COLR2%             ;BACKGROUND COLOR
  74. '    DATA$              ;VARIABLE THE ENTRY IS STORED IN
  75. '
  76. '    MODE%              ;0 = ENTER
  77. '                       ;1 = EDIT WITH CURSOR AT THE END OF THE DATA FIELD
  78. '                       ;2 = EDIT WITH CURSOR AT THE BEGINNING OF THE FIELD
  79. '                       ;3 = DISPLAY THE DATA FIELD
  80. '                       ;4 = CLEAR THE DATA FIELD
  81. '
  82. '    SHOW%              ;0 = DOTS (DEF)
  83. '                       ;1 = BLANKS
  84. '                       ;2 = UNDERSCORE
  85. '                       ;3 = NO SHOW
  86. '
  87. '    VKEY$ = "XXX"      ;3 CHAR INPUT -- ONLY VALID IN ENTER AND EDIT MODES
  88. '                       ;CHAR 1 -- P = ALLOW PFKEY USE
  89. '                       ;CHAR 2 -- A = ALLOW UP AND DOWN ARROW USE
  90. '                       ;CHAR 3 -- T = ALLOW TAB AND BACKTAB EXIT FROM SUB
  91. '                       ;ALL CH -- N = DO NOT ALLOW USE OF KEY (DEF)
  92. '
  93. '    RET%               INPUT
  94. '                       ;0 = NON-DESTRUCTIVE ENTER KEY IN EDIT MODE (DEF)
  95. '                       ;1 = DESTRUCTIVE ENTER KEY IN EDIT MODE
  96. '                       OUTPUT  -- NOT USED IN DISPLAY OR CLEAR MODE
  97. '                       ;0 = ENTER KEY PRESSED OR FIELD FILLED
  98. '                       ;1-9 = PF KEY PRESSED
  99. '                       ;10  = ESC KEY
  100. '                       ;11  = UP ARROW
  101. '                       ;12  = DOWN ARROW
  102. '                       ;13  = TAB
  103. '                       ;14  = BACKTAB
  104. '
  105. '------------------------------------------------------------------------------
  106.  
  107. '-------- SET INITIAL CONDITIONS ------------
  108.                 CURSORX = 0
  109.                 COLOR COLR1, COLR2
  110.                 LOCATE ROW, COL + CURSORX
  111.  
  112.                 IF MODE = 0 OR MODE = 4 THEN    'If enter or clear mode
  113.                     Data$ = SPACE$(LENGTH)      'clear data
  114.                     IF SHOW = 1 THEN            'and show _ . or " "
  115.                         PRINT SPACE$(LENGTH)
  116.                     ELSEIF SHOW = 2 THEN
  117.                         PRINT STRING$(LENGTH, "_")
  118.                     ELSEIF SHOW <> 3 THEN
  119.                         PRINT STRING$(LENGTH, ".")
  120.                     END IF
  121.                 END IF
  122.  
  123.                 IF (MODE = 1 OR MODE = 2) AND RET = 1 THEN
  124.                         RETRN = 1                       'set return type
  125.                 ELSE
  126.                         RETRN = 0
  127.                 END IF
  128.                 RET = 0
  129.  
  130.                 Data$ = LEFT$(Data$, LENGTH)            'cut off excess data
  131.                 IF LEN(Data$) < LENGTH THEN             'pad with spaces
  132.                         Data$ = Data$ + SPACE$(LENGTH - LEN(Data$))
  133.                 END IF
  134.                 IF MODE >= 1 AND MODE <= 3 THEN PRINT Data$
  135.  
  136.                 IF MODE = 3 OR MODE = 4 THEN GOTO EXITSUB
  137.  
  138.                 PFKEY = 0: ARROW = 0: TABKEY = 0
  139.                 VKEYLEN = LEN(VKEY$)          'set VKEY$ variables
  140.                 IF VKEYLEN > 0 AND MID$(VKEY$, 1, 1) = "P" THEN PFKEY = -1
  141.                 IF VKEYLEN > 1 AND MID$(VKEY$, 2, 1) = "A" THEN ARROW = -1
  142.                 IF VKEYLEN > 2 AND MID$(VKEY$, 3, 1) = "T" THEN TABKEY = -1
  143.  
  144.                 Data$ = RTRIM$(Data$)
  145.                 LENDATA = LEN(Data$)
  146.                 IF MODE = 1 AND LENDATA < LENGTH THEN
  147.                   CURSORX = LENDATA     'put cursor at end of field for mode 1
  148.                 ELSEIF MODE = 1 THEN
  149.                   CURSORX = LENGTH - 1
  150.                 END IF
  151.  
  152. '----------- MAIN LOOP ---------
  153.                 DO
  154.                         MOVEX = 0
  155.  
  156.                         IF LEN(Data$) < LENGTH THEN
  157.                                 Data$ = Data$ + SPACE$(LENGTH - LEN(Data$))
  158.                         END IF
  159.                         UNDERCURSOR$ = MID$(Data$, CURSORX + 1, 1)
  160.  
  161. ' ---------- PRINT CURSOR ----------
  162.                         LOCATE ROW, COL + CURSORX
  163.                         COLOR COLR2, COLR1
  164.                         PRINT UNDERCURSOR$
  165.  
  166. ' ---------- GET INPUT -----------
  167.                         a$ = ""
  168.                         WHILE a$ = ""
  169.                                 a$ = INKEY$
  170.                         WEND
  171.                         a = ASC(RIGHT$(a$, 1)) + 256 * (LEN(a$) - 1)
  172.  
  173.                         SELECT CASE a
  174.                            CASE 27                      'esc key
  175.                                 RET = 10
  176.                                 GOTO EXITSUB
  177.                            CASE 13                      'enter key
  178. EXITSUB:                        LOCATE ROW, COL + CURSORX
  179.                                 COLOR COLR1, COLR2   'print cursor
  180.                                 PRINT UNDERCURSOR$
  181.  
  182.                                 IF (RETRN = 1 OR MODE = 0) AND CURSORX + 1 <> LENGTH THEN
  183.                                       LOCATE ROW, COL + CURSORX         'destructive enter
  184.                                       PRINT SPACE$(LENGTH - CURSORX)
  185.                                       MID$(Data$, CURSORX + 1, LENGTH - CURSORX) = SPACE$(LENGTH - CURSORX)
  186.                                 END IF
  187.                                 EXIT SUB
  188.                            CASE 8                       'bs key
  189.                                 UNDERCURSOR$ = " ": MOVEX = -1
  190.                            CASE 9                       'tab key
  191.                                 IF TABKEY THEN
  192.                                         RET = 13
  193.                                         GOTO EXITSUB
  194.                                 ELSE
  195.                                         MOVEX = 5
  196.                                 END IF
  197.                            CASE 32 TO 255               'valid character
  198.                                 UNDERCURSOR$ = a$: MOVEX = 1
  199.                            CASE 315 TO 324               'PF KEY
  200.                                 IF PFKEY THEN RET = a - 314: GOTO EXITSUB
  201.                            CASE 327                     'home key
  202.                                 MOVEX = -CURSORX
  203.                            CASE 328                     'up arrow
  204.                                 IF ARROW THEN RET = 11: GOTO EXITSUB
  205.                            CASE 336                     'down arrow
  206.                                 IF ARROW THEN RET = 12: GOTO EXITSUB
  207.                            CASE 335                     'end key
  208.                                 MOVEX = LEN(RTRIM$(Data$)) - CURSORX
  209.                            CASE 331                     'left arrow
  210.                                 MOVEX = -1
  211.                            CASE 333                     'right arrow
  212.                                 MOVEX = 1
  213.                            CASE 271                     'backtab key
  214.                                 IF TABKEY THEN
  215.                                         RET = 14
  216.                                         GOTO EXITSUB
  217.                                 ELSE
  218.                                         MOVEX = -5
  219.                                 END IF
  220.                         END SELECT
  221.  
  222.  
  223. ' ---------- CLEAR CURSOR ----------
  224.                         LOCATE ROW, COL + CURSORX
  225.                         COLOR COLR1, COLR2
  226.                         PRINT UNDERCURSOR$
  227.  
  228.                         a$ = LEFT$(Data$, CURSORX) + UNDERCURSOR$:  IF CURSORX < LEN(Data$) THEN Data$ = a$ + RIGHT$(Data$, LEN(Data$) - CURSORX - 1)
  229.                         IF CURSORX + MOVEX > LENGTH - 1 AND a > 30 AND a < 256 GOTO EXITSUB
  230.  
  231.                         IF CURSORX + MOVEX > LENGTH - 1 THEN MOVEX = 0
  232.                         IF CURSORX + MOVEX < 0 THEN MOVEX = 0
  233.                         CURSORX = CURSORX + MOVEX
  234.                 LOOP
  235.  
  236. END SUB
  237.  
  238. DEFSNG A-Z
  239. DEFINT A-Z
  240. DEFINT A-Z
  241. FUNCTION Fexists (File$)
  242.         a$ = DIR$(File$)
  243.         IF a$ <> "" THEN
  244.                 Fexists = -1
  245.         ELSE
  246.                 Fexists = 0
  247.         END IF
  248. END FUNCTION
  249.  
  250. DEFSNG A-Z
  251. DEFINT A-Z
  252. DEFINT A-Z
  253. SUB Frame (options, cx, CY, CW, CL, cfor, cback, ARRAYSTART, BUFFER$())
  254.                 cwatt = cfor + cback * 16
  255.                 flag = 0
  256.                 mx = cx + CW / 2 - 1
  257.                 my = CY + CL / 2
  258.  
  259.                 CHGMOD = 1
  260.                 tx = CHGMOD
  261.                 IF CW > 0 THEN
  262.                         ty# = CHGMOD * (CL / CW)
  263.                 ELSE
  264.                         ty# = 0
  265.                 END IF
  266.                 kw = 2 * INT(CW / 2) + 1
  267.                 x1 = mx
  268.                 x2 = mx
  269.                 sy1# = my
  270.                 sy2# = my
  271.  
  272.                 WHILE (x1 > cx AND (options AND 4) = 4)
  273.  
  274.                         x1 = x1 - tx
  275.                         x2 = x2 + tx
  276.                         sy1# = sy1# - ty#
  277.                         sy2# = sy2# + ty#
  278.                         IF sy1# > INT(sy1#) + .5 THEN
  279.                                 y1 = INT(sy1#) + 1
  280.                         ELSE
  281.                                 y1 = INT(sy1#)
  282.                         END IF
  283.  
  284.                         IF sy2# > INT(sy2#) + .5 THEN
  285.                                 y2 = INT(sy2#) + 1
  286.                         ELSE
  287.                                 y2 = INT(sy2#)
  288.                         END IF
  289.  
  290.                         tw = x2 - x1 - 1
  291.  
  292.                         GOSUB PrintFrame
  293.                 WEND
  294.  
  295.                 flag = 1
  296.                 x1 = cx
  297.                 y1 = CY
  298.                 x2 = x1 + CW + 1
  299.                 y2 = y1 + CL + 1
  300.                 tw = CW
  301.                 kw = CW
  302.  
  303. PrintFrame:
  304.                 CALL PUTSTRNG(x1, y1, 1, cwatt, CHR$(201))
  305.                 CALL PUTSTRNG(x1, y2, 1, cwatt, CHR$(200))
  306.                 CALL PUTSTRNG(x2, y1, 1, cwatt, CHR$(187))
  307.                 CALL PUTSTRNG(x2, y2, 1, cwatt, CHR$(188))
  308.  
  309.                 CALL PUTSTRNG(x1 + 1, y1, tw, cwatt, STRING$(tw, 205))
  310.                 CALL PUTSTRNG(x1 + 1, y2, tw, cwatt, STRING$(tw, 205))
  311.                 FOR i = y1 + 1 TO y2 - 1
  312.  
  313.                         IF tw < kw THEN
  314.                                 li$ = MID$(BUFFER$(ARRAYSTART + i - y1 - 1) + SPACE$(kw), (kw - tw) / 2, tw)
  315.                         ELSE
  316.                                 li$ = LEFT$(BUFFER$(ARRAYSTART + i - y1 - 1) + SPACE$(kw), kw)
  317.                         END IF
  318.  
  319.                         IF flag = 1 AND (options AND 1) = 1 THEN
  320.                                 BUFFER$(ARRAYSTART + i - y1 - 1) = ""
  321.                         END IF
  322.                         CALL PUTSTRNG(x1, i, tw + 2, cwatt, CHR$(186) + li$ + CHR$(186))
  323.                 NEXT i
  324.  
  325.                 IF (options AND 2) = 2 AND flag = 1 THEN
  326.  
  327.                         CALL SAVESCRN(x1 - 1, y1 + 1, 1, y2 - y1, buf$)
  328.                         slen = LEN(buf$)
  329.                         FOR i = 1 TO slen STEP 2
  330.                                 buf$ = LEFT$(buf$, i) + CHR$(8) + RIGHT$(buf$, slen - i - 1)
  331.                         NEXT i
  332.                         CALL RESTSCRN(x1 - 1, y1 + 1, 1, y2 - y1, buf$)
  333.  
  334.                         CALL SAVESCRN(x1 - 1, y2 + 1, tw + 2, 1, buf$)
  335.                         slen = LEN(buf$)
  336.                         FOR i = 1 TO slen STEP 2
  337.                                 buf$ = LEFT$(buf$, i) + CHR$(8) + RIGHT$(buf$, slen - i - 1)
  338.                         NEXT i
  339.                         CALL RESTSCRN(x1 - 1, y2 + 1, tw + 2, 1, buf$)
  340.  
  341.                 END IF
  342.                 IF flag = 0 THEN RETURN
  343.  
  344. END SUB
  345.  
  346. DEFSNG A-Z
  347. DEFINT A-Z
  348. DEFINT A-Z
  349. SUB GetDate (CurrDate$)
  350.  
  351.   DIM MO$(12)
  352.  
  353.   MO$(1) = "January": MO$(2) = "February": MO$(3) = "March": MO$(4) = "April"
  354.   MO$(5) = "May": MO$(6) = "June": MO$(7) = "July": MO$(8) = "August"
  355.   MO$(9) = "September": MO$(10) = "October": MO$(11) = "November": MO$(12) = "December"
  356.  
  357.   'Get the date.
  358.   C$ = DATE$
  359.   'Use VAL to find the month from the string returned by DATE$.
  360.   MONTH$ = MO$(VAL(C$))
  361.   'Get the day.
  362.   DAY$ = MID$(C$, 4, 2)
  363.   IF LEFT$(DAY$, 1) = "0" THEN DAY$ = RIGHT$(DAY$, 1)
  364.   'Get the year.
  365.   YEAR$ = RIGHT$(C$, 4)
  366.   CurrDate$ = MONTH$ + " " + DAY$ + ", " + YEAR$
  367.  
  368.   WindowBuffer$(1) = "      The System Date is:"
  369.   WindowBuffer$(2) = "          " + CurrDate$
  370.   WindowBuffer$(4) = "    1  Enter Another Date"
  371.   WindowBuffer$(5) = "    2  Return to the Main Menu"
  372.   WindowBuffer$(7) = "    Press Any Key To Continue"
  373.   CALL Frame(3, 24, 7, 35, 9, 7, 1, 0, WindowBuffer$())
  374.   a$ = INPUT$(1)
  375.   IF a$ = "2" THEN CurrDate$ = "EXIT"
  376.   IF a$ <> "1" THEN EXIT SUB
  377.  
  378. startit:
  379.    NewClear 6, 0
  380.    WindowBuffer$(1) = "         ENTER THE DATE (MMDDYY)"
  381.    WindowBuffer$(3) = "   "
  382.    CALL Frame(3, 16, 2, 48, 6, 3, 1, 0, WindowBuffer$())
  383.  
  384.     LOCATE 7, 36
  385.     COLOR 3, 1
  386.     INPUT ; "", DTE$
  387.  
  388.    GOSUB CHECKDATE: IF INVALID = 1 THEN BEEP: GOTO startit
  389.    GOSUB GETMONTH
  390.    EXIT SUB
  391.  
  392. CHECKDATE:
  393.         INVALID = 0
  394.         DMM$ = MID$(DTE$, 1, 2): DDD$ = MID$(DTE$, 3, 2): DYY$ = MID$(DTE$, 5, 2)
  395.         DMM = VAL(DMM$): DYY = VAL(DYY$): DDD = VAL(DDD$)
  396.         IF DDD < 1 OR DDD > 31 THEN INVALID = 1: RETURN
  397.         IF (DMM = 4 OR DMM = 6 OR DMM = 9 OR DMM = 11) AND DDD > 30 THEN INVALID = 1: RETURN
  398.         IF DYY <= 80 THEN INVALID = 1: RETURN
  399.         IF DMM <> 2 THEN RETURN
  400.         IF DDD > 29 THEN INVALID = 1: RETURN
  401.         IF ((DYY MOD 4) <> 0) AND DDD > 28 THEN INVALID = 1: RETURN
  402.  
  403. GETMONTH:
  404.         MON$ = LEFT$(DTE$, 2)
  405.         CURRMON = VAL(MON$)
  406.         MONTH$ = MO$(CURRMON)
  407.         DAY$ = STR$(VAL(MID$(DTE$, 3, 2))): YEAR$ = "19" + RIGHT$(DTE$, 2)
  408.         CurrDate$ = MONTH$ + DAY$ + ", " + YEAR$
  409.         CURRDAY = VAL(DAY$)
  410.         CURRYEAR = VAL(MID$(YEAR$, 3, 2))
  411.         RETURN
  412.  
  413. END SUB
  414.  
  415. DEFSNG A-Z
  416. REM $DYNAMIC
  417. DEFINT A-Z
  418. DEFINT A-Z
  419. REM $DYNAMIC
  420. SUB NewClear (COLR1, COLR2)
  421.   CALL PUTSTRNG(0, 0, 2000, COLR1 + COLR2 + 16, STRING$(2000, 177))
  422. END SUB
  423.  
  424.